home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / jackal1a.lha / jacal / sexp.scm < prev    next >
Encoding:
Text File  |  1992-12-24  |  12.9 KB  |  401 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; our local environments
  6. (define heqput! (hash-associator eq?))
  7. (define heqrem! (hash-remover eq?))
  8. (define hassq (predicate->hash-asso eq?))
  9.  
  10. (define (defsym sym value)
  11.   (heqput! *symdefs* sym value) value)
  12. (define (undefsym sym)
  13.   (heqrem! *symdefs* sym)
  14.   (var->expl (sexp->var sym)))
  15.  
  16. (define infodefs (make-hash-table 27))
  17. (define (infodef sym) (let ((p (hassq sym infodefs))) (and p (cdr p))))
  18. (define (defbltn sym val . info)
  19.   (var_set-def! (sexp->var sym) val)
  20.   (heqput! infodefs sym info)
  21.   sym)
  22.  
  23. ;;; hdns here is a list of lexically bound symbols as in lambda or suchthat.
  24. ;;; so it is really a list of things not to look up.
  25. (define (symdef-lookup sym hdns)
  26.   (cond ((null? hdns)
  27.      (let ((p (hassq sym *symdefs*)))
  28.        (if p (cdr p) (var->expl (sexp->var sym)))))
  29.     ((eq? sym (car hdns)) (var->expl (sexp->var sym)))
  30.     ((symbol? (car hdns)) (symdef-lookup sym (cdr hdns)))
  31.     ((memq sym (car hdns)) (var->expl (sexp->var sym)))
  32.     (else (symdef-lookup sym (cdr hdns)))))
  33.  
  34. ;;;now for the read-eval-print stuff
  35. (define var-news '())
  36. (define (math . batches)
  37.   (set-handlers!)
  38.   (for-each (lambda (file)
  39.           (batch (if (symbol? file) (symbol->string file) file)))
  40.         batches)
  41.   (display "type ")
  42.   (write-sexp '(qed) *input-grammar*)
  43.   (display " to return to ")
  44.   (display base-language)
  45.   (batch1)
  46.   (cleanup-handlers!)
  47.   base-language)
  48.  
  49. (define (batch file)
  50.   (with-input-from-file file batch1))
  51.  
  52. (define (batch1)
  53.   (do ((math_exit-saved math_exit)
  54.        (var-news-saved var-news)
  55.        (math_prompt #f))
  56.       ((call-with-current-continuation
  57.     (lambda (math_exit-cnt)
  58.       (define obj #f)
  59.       (set! math_exit math_exit-cnt)
  60.       (newline)            ;find unused var
  61.       (do () ((not (or (var-tab-lookup newlabelsym var-tab)
  62.                (hassq newlabelsym *symdefs*))))
  63.         (set! newlabelstr (sect:next-string newlabelstr))
  64.         (set! newlabelsym  (string->symbol newlabelstr)))
  65.       (set! math_prompt (string-append newlabelstr " : "))
  66.       (let loop ()
  67.         (define echoing (not (eq? (get-grammar 'null) *echo-grammar*)))
  68.         (set! var-news '())
  69.         (cond (echoing)
  70.           (else (display math_prompt)
  71.             (force-output)
  72.             (lex:bump-column (string-length math_prompt))))
  73.         (set! obj (read-sexp *input-grammar*))
  74.         (lex:bump-column 0)
  75.         (cond ((not obj) (loop))
  76.           ((eof-object? obj) (math_exit #t))
  77.           (else
  78.            (write-sexp obj *echo-grammar*)
  79.            (if (and (pair? obj) (eq? 'define (car obj)))
  80.                (let* ((var (cadr obj)) (val (sexp->math obj)))
  81.              (out-new-vars var-news)
  82.              (newline)
  83.              (cond ((novalue? val)
  84.                 (sexp->math (list 'define var var))
  85.                 (math-error "no value to set" (cadr obj)))
  86.                    (else
  87.                 (set! % val)
  88.                 (write-sexp (list 'define var (math->sexp val))
  89.                         *output-grammar*))))
  90.                (let* ((var newlabelsym)
  91.                   (val (sexp->math (list 'define var obj))))
  92.              (out-new-vars var-news)
  93.              (newline)
  94.              (cond ((novalue? val)
  95.                 (sexp->math (list 'define var var))
  96.                 (loop))
  97.                    (else
  98.                 (set! % val)
  99.                 (write-sexp (list 'define var (math->sexp val))
  100.                         *output-grammar*))))))))
  101.       #f))
  102.        (set! math_exit math_exit-saved)
  103.        (set! var-news var-news-saved)
  104.        novalue)))
  105.  
  106. (define (out-new-vars var-news)
  107.   (for-each (lambda (x)
  108.           (newline)
  109.           (write-sexp (list 'define
  110.                 (var->sexp x)
  111.                 (math->sexp (vsubst _@ x (extrule x))))
  112.               *output-grammar*))
  113.         var-news))
  114.  
  115. (define (clambda symlist body)
  116.   (if (eqn? body) (poly->eqn (clambda1 symlist (eqn->poly body)))
  117.       (clambda1 symlist body)))
  118.  
  119. (define (clambda1 symlist body)
  120.   (polys_do-vars
  121.    (lambda (var)
  122.      (let ((pos (position (var_nodiffs var) symlist)))
  123.        (if pos (lambda-var (+ 1 pos) (var_diff-depth var))
  124.        var)))
  125.    body))
  126.  
  127. (define (clambda? cexp)
  128.   (cond ((number? cexp) #f)
  129.     ((matrix? cexp) (some (lambda (row) (some clambda? row)) cexp))
  130.     ((expr? cexp) (poly_find-var-if? cexp lambdavar?))
  131.     ((eqn? cexp) (poly_find-var-if? (eqn->poly cexp) lambdavar?))
  132.     (else #f)))
  133.  
  134. ;;;In order to keep the lambda application hygenic (in case a function
  135. ;;;of a function is called), we need to substitute occurences of
  136. ;;;lambda variables in the body with shadowed versions of the
  137. ;;;variables before we eliminate them.  See:
  138. ;;;    Technical Report No. 194
  139. ;;;    Hygenic Macro Expansion
  140. ;;;    E.E.Kohlbecker, D.P.Friedman, M.Fellinson, and B.Duba
  141. ;;;    Indiana University
  142. ;;;    May, 1986
  143.  
  144. ;;;currently capply puts the structure of the clambda inside the
  145. ;;;structure of the arguments.
  146. (define (capply body arglist)
  147.   (set! arglist (licits->poleqns arglist))
  148.   (let ((sbody 0) (svlist '()) (dargs '()) (arglist-length (length arglist)))
  149.     (set! sbody
  150.       (poleqns_do-vars
  151.        (lambda (var)
  152.          (if (lambdavar? var)
  153.          (let ((lshf (- (lambda-position var) arglist-length)))
  154. ;(print 'lambda-position (lambda-position var) 'arglist-length arglist-length 'lshf lshf)
  155.            (cond ((< 0 lshf) (lambda-var lshf (var_diff-depth var)))
  156.              (else (set! var (var_shadow var))
  157.                    (set! svlist (adjoin var svlist))
  158.                    var)))
  159.          var))
  160.        body))
  161.     (set! dargs (diffargs svlist arglist))
  162.     (set! sbody (bunch_map (lambda (p) (eliminate (cons p dargs) svlist))
  163.                sbody))
  164.     (if (eqns? body) (polys->eqns sbody) sbody)))
  165. (define (diffargs vlist args)
  166.       (map (lambda (var)
  167.          (bunch_map (lambda (e)
  168.                   (univ_demote (cons var (cdr (licit->poleqn e)))))
  169.                 (diffarg var args)))
  170.            vlist))
  171. (define (diffarg var args)
  172.   (cond ((var_differential? var)
  173.      (total-differential (diffarg (var_undiff var) args)))
  174.     (else (list-ref args (- (lambda-position var) 1)))))
  175. ;;; _@=fc(_@1) --> _@=fc^^-1(_@1)
  176. (define (fcinverse fc)
  177.   (extize (normalize
  178.        (vsubst _@1 __@
  179.            (vsubst _@ _@1
  180.                (vsubst __@ _@ (licit->poleqn fc)))))))
  181. ;;; fc(fc(...fc(_@1)))
  182. (define (fcexpt fc pow)
  183.   (if (negative? pow)
  184.       (fcexpt (fcinverse fc) (- pow))
  185.     (ipow-by-squaring fc pow cidentity app*)))
  186.  
  187. (define (rapply ob . arglist)
  188.   (cond ((null? arglist) ob)
  189.     ((bunch? ob)
  190.      (apply rapply
  191.         (list-ref ob (+ -1 (plicit->integer (car arglist))))
  192.         (cdr arglist)))
  193.     (else #f)))
  194.  
  195. (define (sapply fun args)
  196.   (cond ((procedure? fun) (apply fun args))
  197.     ((clambda? fun)
  198.      (cond (math_trace
  199.         (newline-diag)
  200.         (write-sexp (math->sexp fun) *output-grammar*)
  201.         (newline-diag)
  202.         (display-diag "applied to:")
  203.         (map (lambda (x)
  204.                (newline-diag)
  205.                (write-sexp (math->sexp x) *output-grammar*))
  206.              args)
  207.         (newline-diag)
  208.         (display-diag "yielding:")
  209.         (newline-diag)
  210.         (let ((ans (capply fun args)))
  211.           (write-sexp (math->sexp ans) *output-grammar*)
  212.           (newline-diag)
  213.           ans))
  214.            (else (capply fun args))))
  215.     ((rat_number? fun) (eval-error "wrong type to apply: " fun))
  216.     (else (apply deferop (math->sexp fun) args))))
  217.  
  218. (define (app* fun . args) (sapply fun args))
  219.  
  220. (define (seval f hdns)
  221.   (cond ((number? f)
  222.      (if (inexact? f) (eval-error "Inexact number to eval: "))
  223.        (cond ((integer? f) f)
  224.              ((rational? f) (make-rat (numerator f) (denominator f)))))
  225.     ((vector? f) (map (lambda (x) (seval x hdns)) (vector->list f)))
  226.     ((symbol? f) (symdef-lookup f hdns))
  227.     ((boolean? f) f)
  228.     ((null? f) f)
  229.     ((not (pair? f)) (eval-error "Wrong type to eval: " f))
  230.     ((eqv? (car f) 'lambda)
  231.      (let ((vars (variables
  232.               (cond ((symbol? (cadr f)) (list (cadr f)))
  233.                 ((vector? (cadr f)) (vector->list (cadr f)))
  234.                 ((pair? (cadr f)) (cadr f))
  235.                 (else (eval-error "Bad arglist in lambda: " f))))))
  236.        (clambda vars (seval (caddr f) (cons vars hdns)))))
  237.     ((eqv? (car f) 'suchthat)
  238.      (suchthat (sexp->var (cadr f))
  239.            (seval (caddr f) (cons (cadr f) hdns))))
  240.     ((eqv? (car f) 'define)
  241.      (cond ((symbol? (cadr f))
  242.         (if (eq? (cadr f) (caddr f))
  243.             (undefsym (cadr f))
  244.             (defsym (cadr f)
  245.               (normalize (seval (caddr f) (cons (cadr f) hdns))))))
  246.            ((eqv? (caadr f) 'rapply)
  247.         (defsym (cadadr f)
  248.           (rlambda (cddadr f)
  249.                (normalize (seval (caddr f)
  250.                          (cons (cdadr f) hdns))))))
  251.            (else            ;must be capply
  252.         (defsym (caadr f)
  253.           (clambda (variables (cdadr f))
  254.                (normalize (seval (caddr f)
  255.                          (cons (cadr f) hdns))))))))
  256.     (else
  257.      (let ((ff (seval (car f) hdns)))
  258.        (sapply (or (and (pair? ff)
  259.                 (expl? ff)
  260.                 (equal? (cdr ff) '(0 1))
  261.                 (not (number? (var_def (car ff))))
  262.                 (var_def (car ff)))
  263.                ff)
  264.            (map (lambda (x) (seval x hdns)) (cdr f)))))))
  265. (define (sexp->math f) (seval f '()))
  266.  
  267. ;;; These routines convert LICITs or parts of LICITs to S-EXPRESSIONs
  268. (define (cmprs_+ res)
  269.   (cond ((null? (cdr res)) (car res))
  270.     ((and (pair? (cadr res)) (eq? 'negate (caadr res)))
  271.      (cmprs_+ (cons (list '- (car res) (cadadr res)) (cddr res))))
  272.     ((and (pair? (car res)) (eq? '+ (caar res)))
  273.      (if (null? (cddr res)) (nconc (car res) (cdr res))
  274.          (cmprs_+ (cons (nconc (car res) (list (cadr res))) (cddr res)))))
  275.     ((null? (cddr res)) (cons '+ res))
  276.     (else (cmprs_+ (cons (list '+ (car res) (cadr res)) (cddr res))))))
  277.  
  278. (define (cmprs_* mu mex)
  279.   (cond ((pair? mu)
  280.      (cond ((eq? '* (car mu)) (nconc mu (list mex)))
  281.            ((eq? 'negate (car mu))
  282.         (list 'negate (cmprs_* (cadr mu) mex)))
  283.            (else (list '* mu mex))))
  284.     ((and (number? mu) (negative? mu))
  285.      (if (eq? -1 mu)
  286.          (list 'negate mex)
  287.          (list 'negate (list '* (- mu) mex))))
  288.     (else (if (eq? 1 mu) mex (list '* mu mex)))))
  289.  
  290. (define (cmprs_^ var exp)
  291.   (cond ((one? exp) var)
  292.     ((and (pair? var)
  293.           (eq? '^ (car var)))
  294.      (list '^
  295.            (cadr var)
  296.            (if (and (pair? (caddr var))
  297.             (eq? '/ (caaddr var))
  298.             (one? (cadr (caddr var))))
  299.            (list '/ exp (caddr (caddr var)))
  300.            (cmprs_* exp (caddr var)))))
  301.     (else (list '^ var exp))))
  302.  
  303. ;POLY->SEXP converts a polynomial to SEXPRESSION.
  304. (define (poly->sexp p)
  305.   (cond ((number? p) p)
  306.     (horner (coes->horner-sexp (var->sexp (car p)) 0 (cdr p)))
  307.     (else (cmprs_+ (coes->sexp (var->sexp (car p)) 0 (cdr p))))))
  308. (define (coes->horner-sexp var exp colist)
  309.   (cond ((eqv? 0 (car colist)) (coes->horner-sexp var (+ 1 exp) (cdr colist)))
  310.     ((null? (cdr colist))
  311.      (if (zero? exp) (poly->sexp (car colist))
  312.          (cmprs_* (poly->sexp (car colist)) (cmprs_^ var exp))))
  313.     ((zero? exp)
  314.      (cmprs_+ (list (poly->sexp (car colist))
  315.             (coes->horner-sexp var 1 (cdr colist)))))
  316.     (else
  317.      (cmprs_*
  318.       (cmprs_+ (list (poly->sexp (car colist))
  319.              (coes->horner-sexp var 1 (cdr colist))))
  320.       (cmprs_^ var exp)))))
  321. (define (coes->sexp var exp colist)
  322.   (cond ((null? colist) colist)
  323.     ((eqv? 0 (car colist)) (coes->sexp var (+ 1 exp) (cdr colist)))
  324.     ((zero? exp) (cons (poly->sexp (car colist))
  325.                (coes->sexp var (+ 1 exp) (cdr colist))))
  326.     ((eqv? 1 (car colist))
  327.      (cons (cmprs_^ var exp) (coes->sexp var (+ 1 exp) (cdr colist))))
  328.     (else (cons (cmprs_* (poly->sexp (car colist)) (cmprs_^ var exp))
  329.             (coes->sexp var (+ 1 exp) (cdr colist))))))
  330. ;RAT->SEXP converts a rational polynomial to SEXPRESSION.
  331. (define (rat->sexp n d)
  332.   (if (unit? d)
  333.       (poly->sexp (poly_* n d))
  334.       (list 'over (poly->sexp n) (poly->sexp d))))
  335.  
  336. (define (impl_radical? p) (one? (length (or (memv 0 (cddr p)) '()))))
  337. ;;;IMPOLY->SEXP converts an implicit polynomial to SEXPRESSION.
  338. (define (impoly->sexp p)
  339.   (if (impl_radical? p)
  340.       (list '=
  341.         (if (null? (cdddr p))
  342.         (var->sexp (car p))
  343.         ;;I cant exercise this clause:
  344.         (list '^ (var->sexp (car p)) (length (cddr p))))
  345.         (rat->sexp (cadr p) (car (last-pair p))))
  346.     (list '= 0 (poly->sexp p))))
  347.  
  348. ;;;IRIMPL->SEXP converts an irreducible implicit expression to SEXPRESSION.
  349. (define (irimpl->sexp p)
  350.   (let ((dgr (poly_degree p _@)))
  351.     (cond ((zero? dgr) (math:warn "not canonical " p) p)
  352.       ((one? dgr) (rat->sexp (rat_num p) (rat_denom p)))
  353.       (else (list 'suchthat (var->sexp (car p)) (impoly->sexp p))))))
  354.  
  355. (define (bunch->sexp p)
  356.   (cond ((bunch? p) (list->vector (map bunch->sexp p)))    ;inefficient
  357.     ((symbol? p) p)
  358.     ((expl? p) (poly->sexp p))
  359.     ((impl? p)
  360.      (let ((dgr (poly_degree p _@)))
  361.        (cond ((zero? dgr) (math:warn "not canonical " p) p)
  362.          ((one? dgr) (rat->sexp (rat_num p) (rat_denom p)))
  363.          (else
  364.           (let ((fcts (map irimpl->sexp (univ_split-all p))))
  365.             (if (null? (cdr fcts)) (car fcts)
  366.             (cons 'or fcts)))))))
  367.     ((eqn? p) (list '= 0 (poly->sexp (eqn->poly p))))
  368.     (else (eval-error "unknown type to display " p))))
  369.  
  370. (define (highest-lambda-var polys)
  371.   (let ((maxpos 0) (deps '()))
  372.     (polys_for-each-var
  373.      (lambda (v) (if (lambdavar? v)
  374.              (if (extrule v)
  375.              (set! deps (adjoin v deps))
  376.                (set! maxpos (max maxpos (lambda-position v))))))
  377.      polys)
  378.     (for-each
  379.      (lambda (v)
  380.        (for-each
  381.     (lambda (x) (if (lambdavar? x)
  382.             (set! maxpos (max maxpos (lambda-position x)))))
  383.     (var_depends v)))
  384.      deps)
  385.     maxpos))
  386. (define (get-lambda-list poly)
  387.   (do ((j (highest-lambda-var poly) (+ -1 j))
  388.        (ll '()
  389.        (cons (string->symbol (string-append "@" (number->string j))) ll)))
  390.       ((< j 1) ll)))
  391.  
  392. ;;;MATH->SEXP converts expressions or equations to SEXPRESSIONS. 
  393. (define (math->sexp p)
  394.   (if (clambda? p)
  395.       (list 'lambda (list->vector (get-lambda-list
  396.                    (if (eqn? p) (eqn->poly p) p)))
  397.         (bunch->sexp p))
  398.       (bunch->sexp p)))
  399.  
  400. ;;;    Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
  401.